home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlsym.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  5.1 KB  |  258 lines
  1. /* xlsym - symbol handling routines */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8.  
  9. /* external variables */
  10. extern LVAL obarray,s_unbound;
  11. extern LVAL xlenv,xlfenv;
  12. extern LVAL true;        /* Bug fix TAA */
  13.  
  14. /* forward declarations */
  15. #ifdef ANSI
  16. LVAL findprop(LVAL sym, LVAL prp);
  17. #else
  18. FORWARD LVAL findprop();
  19. #endif
  20.  
  21. /* xlenter - enter a symbol into the obarray */
  22. LVAL xlenter(name)
  23.   char *name;
  24. {
  25.     LVAL sym,array;
  26.     int i;
  27.  
  28.     /* check for nil */
  29.     if (strcmp(name,"NIL") == 0)
  30.         return (NIL);
  31.  
  32.     /* check for symbol already in table */
  33.     array = getvalue(obarray);
  34.     i = hash(name,HSIZE);
  35.     for (sym = getelement(array,i); sym; sym = cdr(sym))
  36.         if (strcmp(name,(char *)getstring(getpname(car(sym)))) == 0)
  37.             return (car(sym));
  38.  
  39.     /* make a new symbol node and link it into the list */
  40.     xlsave1(sym);
  41.     sym = consd(getelement(array,i));
  42.     rplaca(sym,xlmakesym(name));
  43.     setelement(array,i,sym);
  44.     xlpop();
  45.  
  46.     /* return the new symbol */
  47.     return (car(sym));
  48. }
  49.  
  50. /* xlmakesym - make a new symbol node */
  51. LVAL xlmakesym(name)
  52.   char *name;
  53. {
  54.     LVAL sym;
  55.     sym = cvsymbol(name);
  56.     if (*name == ':')
  57.         setvalue(sym,sym);
  58.     return (sym);
  59. }
  60.  
  61. /* xlgetvalue - get the value of a symbol (with check) */
  62. LVAL xlgetvalue(sym)
  63.   LVAL sym;
  64. {
  65.     LVAL val;
  66.  
  67.     /* look for the value of the symbol */
  68.     while ((val = xlxgetvalue(sym)) == s_unbound)
  69.         xlunbound(sym);
  70.  
  71.     /* return the value */
  72.     return (val);
  73. }
  74.  
  75. /* xlxgetvalue - get the value of a symbol */
  76. LVAL xlxgetvalue(sym)
  77.   LVAL sym;
  78. {
  79.     register LVAL fp,ep;
  80.     LVAL val;
  81.  
  82.     /* check the environment list */
  83.     for (fp = xlenv; fp; fp = cdr(fp))
  84.  
  85.         /* check for an instance variable */
  86.         if (((ep = car(fp)) != 0) && objectp(car(ep))) {
  87.             if (xlobgetvalue(ep,sym,&val))
  88.                 return (val);
  89.         }
  90.  
  91.         /* check an environment stack frame */
  92.         else {
  93.             for (; ep; ep = cdr(ep))
  94.                 if (sym == car(car(ep)))
  95.                     return (cdr(car(ep)));
  96.         }
  97.  
  98.     /* return the global value */
  99.     return (getvalue(sym));
  100. }
  101.  
  102. /* xlsetvalue - set the value of a symbol */
  103. VOID xlsetvalue(sym,val)
  104.   LVAL sym,val;
  105. {
  106.     register LVAL fp,ep;
  107.  
  108.  
  109.     if ( sym == true || 
  110.          sym == s_unbound ||
  111.          (getstring(getpname(sym)))[0] == ':') {    /* Bug FIX    TAA */
  112.         xlerror( "constant value", sym );
  113.         return;
  114.     }
  115.  
  116.     /* look for the symbol in the environment list */
  117.     for (fp = xlenv; fp; fp = cdr(fp))
  118.  
  119.         /* check for an instance variable */
  120.         if (((ep = car(fp)) != 0) && objectp(car(ep))) {
  121.             if (xlobsetvalue(ep,sym,val))
  122.                 return;
  123.         }
  124.  
  125.         /* check an environment stack frame */
  126.         else {
  127.             for (; ep; ep = cdr(ep))
  128.                 if (sym == car(car(ep))) {
  129.                     rplacd(car(ep),val);
  130.                     return;
  131.                 }
  132.         }
  133.  
  134.     /* store the global value */
  135.     setvalue(sym,val);
  136. }
  137.  
  138. /* xlgetfunction - get the functional value of a symbol (with check) */
  139. LVAL xlgetfunction(sym)
  140.   LVAL sym;
  141. {
  142.     LVAL val;
  143.  
  144.     /* look for the functional value of the symbol */
  145.     while ((val = xlxgetfunction(sym)) == s_unbound)
  146.         xlfunbound(sym);
  147.  
  148.     /* return the value */
  149.     return (val);
  150. }
  151.  
  152. /* xlxgetfunction - get the functional value of a symbol */
  153. LVAL xlxgetfunction(sym)
  154.   LVAL sym;
  155. {
  156.     register LVAL fp,ep;
  157.  
  158.     /* check the environment list */
  159.     for (fp = xlfenv; fp; fp = cdr(fp))
  160.         for (ep = car(fp); ep; ep = cdr(ep))
  161.             if (sym == car(car(ep)))
  162.                 return (cdr(car(ep)));
  163.  
  164.     /* return the global value */
  165.     return (getfunction(sym));
  166. }
  167.  
  168. /* xlsetfunction - set the functional value of a symbol */
  169. VOID xlsetfunction(sym,val)
  170.   LVAL sym,val;
  171. {
  172.     register LVAL fp,ep;
  173.  
  174.     /* look for the symbol in the environment list */
  175.     for (fp = xlfenv; fp; fp = cdr(fp))
  176.         for (ep = car(fp); ep; ep = cdr(ep))
  177.             if (sym == car(car(ep))) {
  178.                 rplacd(car(ep),val);
  179.                 return;
  180.             }
  181.  
  182.     /* store the global value */
  183.     setfunction(sym,val);
  184. }
  185.  
  186. /* xlgetprop - get the value of a property */
  187. LVAL xlgetprop(sym,prp)
  188.   LVAL sym,prp;
  189. {
  190.     LVAL p;
  191.     return (((p = findprop(sym,prp)) != 0) ? car(p) : NIL);
  192. }
  193.  
  194. /* xlputprop - put a property value onto the property list */
  195. VOID xlputprop(sym,val,prp)
  196.   LVAL sym,val,prp;
  197. {
  198.     LVAL pair;
  199.     if ((pair = findprop(sym,prp)) != 0)
  200.         rplaca(pair,val);
  201.     else
  202.         setplist(sym,cons(prp,cons(val,getplist(sym))));
  203. }
  204.  
  205. /* xlremprop - remove a property from a property list */
  206. VOID xlremprop(sym,prp)
  207.   LVAL sym,prp;
  208. {
  209.     LVAL last,p;
  210.     last = NIL;
  211.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
  212.         if (car(p) == prp)
  213.             if (last)
  214.                 rplacd(last,cdr(cdr(p)));
  215.             else
  216.                 setplist(sym,cdr(cdr(p)));
  217.         last = cdr(p);
  218.     }
  219. }
  220.  
  221. /* findprop - find a property pair */
  222. LOCAL LVAL findprop(sym,prp)
  223.   LVAL sym,prp;
  224. {
  225.     LVAL p;
  226.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  227.         if (car(p) == prp)
  228.             return (cdr(p));
  229.     return (NIL);
  230. }
  231.  
  232. /* hash - hash a symbol name string */
  233. int hash(str,len)
  234.   char *str;
  235.   int len;
  236. {
  237.     int i;
  238.     for (i = 0; *str; )
  239.         i = (i << 2) ^ *str++;
  240.     i %= len;
  241.     return (i < 0 ? -i : i);
  242. }
  243.  
  244. /* xlsinit - symbol initialization routine */
  245. VOID xlsinit()
  246. {
  247.     LVAL array,p;
  248.  
  249.     /* initialize the obarray */
  250.     obarray = xlmakesym("*OBARRAY*");
  251.     array = newvector(HSIZE);
  252.     setvalue(obarray,array);
  253.  
  254.     /* add the symbol *OBARRAY* to the obarray */
  255.     p = consa(obarray);
  256.     setelement(array,hash("*OBARRAY*",HSIZE),p);
  257. }
  258.